home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
c
/
hash.d
< prev
next >
Wrap
Text File
|
1987-06-03
|
9KB
|
402 lines
/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/
#include "include.h"
object Seq;
object Seql;
object Sequal;
object Ktest;
object Ksize;
object Krehash_size;
object Krehash_threshold;
int
hash_eql(x)
object x;
{
int h;
switch (type_of(x)) {
case t_fixnum:
return(fix(x));
case t_bignum:
h = x->big.big_car;
while (x->big.big_cdr != NULL) {
x = (object)x->big.big_cdr;
h += x->big.big_car;
}
return(h);
case t_ratio:
return(hash_eql(x->rat.rat_num) + hash_eql(x->rat.rat_den));
case t_shortfloat:
return((int)(sf(x)));
case t_longfloat:
return((int)(lf(x)) + *((int *)x + 1));
case t_complex:
return(hash_eql(x->cmp.cmp_real) + hash_eql(x->cmp.cmp_imag));
case t_character:
return(char_code(x));
default:
return((int)x / 4);
}
}
int
hash_equal(x)
object x;
{
int h = 0, i;
char *s;
cs_check(x);
BEGIN:
switch (type_of(x)) {
case t_cons:
h += hash_equal(x->c.c_car);
x = x->c.c_cdr;
goto BEGIN;
case t_string:
for (i = x->st.st_fillp, s = x->st.st_self; i > 0; --i, s++)
h += (*s & 0377)*12345 + 1;
return(h);
case t_bitvector:
return(h);
case t_pathname:
h += hash_equal(x->pn.pn_host);
h += hash_equal(x->pn.pn_device);
h += hash_equal(x->pn.pn_directory);
h += hash_equal(x->pn.pn_name);
h += hash_equal(x->pn.pn_type);
h += hash_equal(x->pn.pn_version);
return(h);
case t_structure:
h += hash_equal(x->str.str_name);
for (i = 0; i < x->str.str_length; i++)
h += hash_equal(x->str.str_self[i]);
return(h);
default:
return(h + hash_eql(x));
}
}
struct htent *
gethash(key, hashtable)
object key;
object hashtable;
{
enum httest htest;
int hsize;
struct htent *e;
object hkey;
int i, j = -1, k; /* k added by chou */
bool b;
htest = (enum httest)hashtable->ht.ht_test;
hsize = hashtable->ht.ht_size;
if (htest == htt_eq)
i = (int)key / 4;
else if (htest == htt_eql)
i = hash_eql(key);
else if (htest == htt_equal)
i = hash_equal(key);
i &= 0x7fffffff;
for (i %= hsize, k = 0; k < hsize; i = (i + 1) % hsize, k++) { /* k added by chou */
e = &hashtable->ht.ht_self[i];
hkey = e->hte_key;
if (hkey == OBJNULL) {
if (e->hte_value == OBJNULL)
if (j < 0)
return(e);
else
return(&hashtable->ht.ht_self[j]);
else
if (j < 0)
j = i;
else
;
continue;
}
if (htest == htt_eq)
b = key == hkey;
else if (htest == htt_eql)
b = eql(key, hkey);
else if (htest == htt_equal)
b = equal(key, hkey);
if (b)
return(&hashtable->ht.ht_self[i]);
}
return(&hashtable->ht.ht_self[j]); /* added by chou */
}
sethash(key, hashtable, value)
object key, hashtable, value;
{
int i;
bool over;
struct htent *e;
i = hashtable->ht.ht_nent + 1;
if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum)
over = i >= fix(hashtable->ht.ht_rhthresh);
else if (type_of(hashtable->ht.ht_rhthresh) == t_shortfloat)
over =
i >= hashtable->ht.ht_size * sf(hashtable->ht.ht_rhthresh);
else if (type_of(hashtable->ht.ht_rhthresh) == t_longfloat)
over =
i >= hashtable->ht.ht_size * lf(hashtable->ht.ht_rhthresh);
if (over)
extend_hashtable(hashtable);
e = gethash(key, hashtable);
if (e->hte_key == OBJNULL)
hashtable->ht.ht_nent++;
e->hte_key = key;
e->hte_value = value;
}
extend_hashtable(hashtable)
object hashtable;
{
object old;
short new_size, i;
if (type_of(hashtable->ht.ht_rhsize) == t_fixnum)
new_size =
hashtable->ht.ht_size + fix(hashtable->ht.ht_rhsize);
else if (type_of(hashtable->ht.ht_rhsize) == t_shortfloat)
new_size =
hashtable->ht.ht_size * sf(hashtable->ht.ht_rhsize);
else if (type_of(hashtable->ht.ht_rhsize) == t_longfloat)
new_size =
hashtable->ht.ht_size * lf(hashtable->ht.ht_rhsize);
old = alloc_object(t_hashtable);
old->ht = hashtable->ht;
vs_push(old);
hashtable->ht.ht_self = NULL;
hashtable->ht.ht_size = new_size;
if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum)
hashtable->ht.ht_rhthresh =
make_fixnum(fix(hashtable->ht.ht_rhthresh) +
(new_size - old->ht.ht_size));
hashtable->ht.ht_self =
(struct htent *)alloc_relblock(new_size * sizeof(struct htent));
for (i = 0; i < new_size; i++) {
hashtable->ht.ht_self[i].hte_key = OBJNULL;
hashtable->ht.ht_self[i].hte_value = OBJNULL;
}
for (i = 0; i < old->ht.ht_size; i++) {
if (old->ht.ht_self[i].hte_key != OBJNULL)
sethash(old->ht.ht_self[i].hte_key,
hashtable,
old->ht.ht_self[i].hte_value);
}
hashtable->ht.ht_nent = old->ht.ht_nent;
vs_pop;
}
@(defun make_hash_table (&key (test Seql)
(size `make_fixnum(1024)`)
(rehash_size
`make_shortfloat((shortfloat)1.5)`)
(rehash_threshold
`make_shortfloat((shortfloat)0.7)`)
&aux h)
enum httest htt;
int i;
@
if (test == Seq || test == Seq->s.s_gfdef)
htt = htt_eq;
else if (test == Seql || test == Seql->s.s_gfdef)
htt = htt_eql;
else if (test == Sequal || test == Sequal->s.s_gfdef)
htt = htt_equal;
else
FEerror("~S is an illegal hash-table test function.",
1, test);
if (type_of(size) != t_fixnum || 0 < fix(size))
;
else
FEerror("~S is an illegal hash-table size.", 1, size);
if (type_of(rehash_size) == t_fixnum && 0 < fix(rehash_size) ||
type_of(rehash_size) == t_shortfloat && 1.0 < sf(rehash_size) ||
type_of(rehash_size) == t_longfloat && 1.0 < lf(rehash_size))
;
else
FEerror("~S is an illegal hash-table rehash-size.",
1, rehash_size);
if (type_of(rehash_threshold) == t_fixnum &&
0 < fix(rehash_threshold) && fix(rehash_threshold) < fix(size) ||
type_of(rehash_threshold) == t_shortfloat &&
0.0 < sf(rehash_threshold) && sf(rehash_threshold) < 1.0 ||
type_of(rehash_threshold) == t_longfloat &&
0.0 < lf(rehash_threshold) && lf(rehash_threshold) < 1.0)
;
else
FEerror("~S is an illegal hash-table rehash-threshold.",
1, rehash_threshold);
h = alloc_object(t_hashtable);
h->ht.ht_test = (short)htt;
h->ht.ht_size = fix(size);
h->ht.ht_rhsize = rehash_size;
h->ht.ht_rhthresh = rehash_threshold;
h->ht.ht_nent = 0;
h->ht.ht_self = NULL;
h->ht.ht_self = (struct htent *)
alloc_relblock(fix(size) * sizeof(struct htent));
for(i = 0; i < fix(size); i++) {
h->ht.ht_self[i].hte_key = OBJNULL;
h->ht.ht_self[i].hte_value = OBJNULL;
}
@(return h)
@)
Lhash_table_p()
{
check_arg(1);
if(type_of(vs_base[0]) == t_hashtable)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
Lgethash()
{
int narg;
struct htent *e;
narg = vs_top - vs_base;
if (narg < 2)
too_few_arguments();
else if (narg == 2)
vs_push(Cnil);
else if (narg > 3)
too_many_arguments();
check_type_hash_table(&vs_base[1]);
e = gethash(vs_base[0], vs_base[1]);
if (e->hte_key != OBJNULL) {
vs_base[0] = e->hte_value;
vs_base[1] = Ct;
} else {
vs_base[0] = vs_base[2];
vs_base[1] = Cnil;
}
vs_pop;
}
siLhash_set()
{
check_arg(3);
check_type_hash_table(&vs_base[1]);
sethash(vs_base[0], vs_base[1], vs_base[2]);
vs_base += 2;
}
Lremhash()
{
struct htent *e;
check_arg(2);
check_type_hash_table(&vs_base[1]);
e = gethash(vs_base[0], vs_base[1]);
if (e->hte_key != OBJNULL) {
e->hte_key = OBJNULL;
e->hte_value = Cnil;
vs_base[1]->ht.ht_nent--;
vs_base[0] = Ct;
} else
vs_base[0] = Cnil;
vs_top = vs_base + 1;
}
Lclrhash()
{
int i;
check_arg(1);
check_type_hash_table(&vs_base[0]);
for(i = 0; i < vs_base[0]->ht.ht_size; i++) {
vs_base[0]->ht.ht_self[i].hte_key = OBJNULL;
vs_base[0]->ht.ht_self[i].hte_value = OBJNULL;
}
vs_base[0]->ht.ht_nent = 0;
}
Lhash_table_count()
{
object z;
check_arg(1);
check_type_hash_table(&vs_base[0]);
vs_base[0] = make_fixnum(vs_base[0]->ht.ht_nent);
}
Lsxhash()
{
check_arg(1);
vs_base[0] = make_fixnum(hash_equal(vs_base[0]) & 0x7fffffff);
}
Lmaphash()
{
object *base = vs_base;
object hashtable;
int i;
check_arg(2);
check_type_hash_table(&vs_base[1]);
hashtable = vs_base[1];
for (i = 0; i < hashtable->ht.ht_size; i++) {
if(hashtable->ht.ht_self[i].hte_key != OBJNULL)
ifuncall2(base[0],
hashtable->ht.ht_self[i].hte_key,
hashtable->ht.ht_self[i].hte_value);
}
vs_base[0] = Cnil;
vs_pop;
}
init_hash()
{
Seq = make_ordinary("EQ");
Seql = make_ordinary("EQL");
Sequal = make_ordinary("EQUAL");
Ksize = make_keyword("SIZE");
Ktest = make_keyword("TEST");
Krehash_size = make_keyword("REHASH-SIZE");
Krehash_threshold = make_keyword("REHASH-THRESHOLD");
make_function("MAKE-HASH-TABLE", Lmake_hash_table);
make_function("HASH-TABLE-P", Lhash_table_p);
make_function("GETHASH", Lgethash);
make_function("REMHASH", Lremhash);
make_function("MAPHASH", Lmaphash);
make_function("CLRHASH", Lclrhash);
make_function("HASH-TABLE-COUNT", Lhash_table_count);
make_function("SXHASH", Lsxhash);
make_si_function("HASH-SET", siLhash_set);
}